home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / Examples / fasl-concatenate.lisp < prev    next >
Encoding:
Text File  |  1993-02-01  |  5.3 KB  |  131 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;; fasl-concatenate.lisp
  4. ;;; Copyright 1992, Apple Computer, Inc
  5. ;;;
  6. ;;; Concatenate fasl files.
  7.  
  8. ;;; Format of a fasl file as expected by the fasloader.
  9. ;;;
  10. ;;; #xFF00         2 bytes - File version
  11. ;;; Block Count    2 bytes - Number of blocks in the file
  12. ;;; addr[0]        4 bytes - address of 0th block
  13. ;;; length[0]      4 bytes - length of 0th block
  14. ;;; addr[1]        4 bytes - address of 1st block
  15. ;;; length[1]      4 bytes - length of 1st block
  16. ;;; ...
  17. ;;; addr[n-1]      4 bytes
  18. ;;; length[n-1]    4 bytes
  19. ;;; length[0] + length[1] + ... + length [n-1] bytes of data
  20.  
  21. (in-package :ccl)
  22.  
  23. (export '(fasl-concatenate))
  24.  
  25. (defconstant $fasl-id #xff00)          ; fasl file id
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28. ;;
  29. ;; (fasl-concatenate out-file fasl-files &key :if-exists)
  30. ;;
  31. ;; out-file     name of file in which to store the concatenation
  32. ;; fasl-files   list of names of fasl files to concatenate
  33. ;; if-exists    as for OPEN. Defaults to :error
  34. ;;
  35. ;; function result: pathname to the output file.
  36. ;; All file types default to "FASL"
  37. ;; It works to use the output of one invocation of fasl-concatenate
  38. ;; as an input of another invocation.
  39. ;;
  40. (defun fasl-concatenate (out-file fasl-files &key (if-exists :error))
  41.   (let ((count 0)
  42.         (created? nil)
  43.         (finished? nil))
  44.     (declare (fixnum count))
  45.     (dolist (file fasl-files)
  46.       (setq file (merge-pathnames file ".fasl"))
  47.       (unless (eq (mac-file-type file) :fasl)
  48.         (error "Not a fasl file: ~s" file))
  49.       (with-open-file (stream file)
  50.         (multiple-value-bind (r ra) (stream-reader stream)
  51.           (unless (eql $fasl-id (reader-read-word r ra))
  52.             (error "Bad fasl file ID in ~s" file))
  53.           (incf count (reader-read-word r ra)))))
  54.     (unwind-protect
  55.       (with-open-file (stream (setq out-file (merge-pathnames out-file ".fasl"))
  56.                               :direction :output
  57.                               :if-does-not-exist :create
  58.                               :if-exists if-exists)
  59.         (set-mac-file-creator out-file :ccl2)
  60.         (set-mac-file-type out-file :fasl)
  61.         (setq created? t)
  62.         (multiple-value-bind (w wa) (stream-writer stream)
  63.           (let ((addr-address 4)
  64.                 (data-address (+ 4 (* count 8))))
  65.             (writer-write-word 0 w wa)         ;  will be $fasl-id
  66.             (writer-write-word count w wa)
  67.             (dotimes (i (* 2 count))
  68.               (writer-write-long 0 w wa))       ; for addresses/lengths
  69.             (dolist (file fasl-files)
  70.               (with-open-file (in-stream (merge-pathnames file ".fasl"))
  71.                 (multiple-value-bind (r ra) (stream-reader in-stream)
  72.                   (reader-read-word r ra)    ; skip ID
  73.                   (let* ((fasl-count (reader-read-word r ra))
  74.                          (addrs (make-array fasl-count))
  75.                          (sizes (make-array fasl-count))
  76.                          addr0)
  77.                     (declare (fixnum fasl-count)
  78.                              (dynamic-extent addrs sizes))
  79.                     (dotimes (i fasl-count)
  80.                       (setf (svref addrs i) (reader-read-long r ra)
  81.                             (svref sizes i) (reader-read-long r ra)))
  82.                     (setq addr0 (svref addrs 0))
  83.                     (file-position stream addr-address)
  84.                     (dotimes (i fasl-count)
  85.                       (writer-write-long
  86.                        (+ data-address (- (svref addrs i) addr0))
  87.                        w wa)
  88.                       (writer-write-long (svref sizes i) w wa)
  89.                       (incf addr-address 8))
  90.                     (file-position stream data-address)
  91.                     (dotimes (i fasl-count)
  92.                       (file-position in-stream (svref addrs i))
  93.                       (let ((fasl-length (svref sizes i)))
  94.                         (dotimes (j fasl-length)
  95.                           (funcall w wa (funcall r ra)))
  96.                         (incf data-address fasl-length)))))))
  97.             (file-length stream data-address)
  98.             (file-position stream 0)
  99.             (writer-write-word $fasl-id w wa)
  100.             (setq finished? t))))
  101.       (when (and created? (not finished?))
  102.         (delete-file out-file))))
  103.   out-file)
  104.  
  105.  
  106. (defun writer-write-byte (byte writer writer-arg)
  107.   (declare (fixnum byte))
  108.   (funcall writer writer-arg (%code-char (logand #xff byte))))
  109.  
  110. (defun writer-write-word (word writer writer-arg)
  111.   (declare (fixnum word))
  112.   (writer-write-byte (the fixnum (ash word -8)) writer writer-arg)
  113.   (writer-write-byte (the fixnum (logand #xff word)) writer writer-arg))
  114.  
  115. (defun writer-write-long (long writer writer-arg)
  116.   (writer-write-word (ash long -16) writer writer-arg)
  117.   (writer-write-word (logand #xffff long) writer writer-arg))
  118.  
  119. (defun reader-read-byte (reader reader-arg)
  120.   (char-code (the character (funcall reader reader-arg))))
  121.  
  122. (defun reader-read-word (reader reader-arg)
  123.   (the fixnum
  124.        (logior (the fixnum 
  125.                     (ash (the fixnum (reader-read-byte reader reader-arg))
  126.                          8))
  127.                (the fixnum (reader-read-byte reader reader-arg)))))
  128.  
  129. (defun reader-read-long (reader reader-arg)
  130.   (logior (ash (reader-read-word reader reader-arg) 16)
  131.           (reader-read-word reader reader-arg)))